home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / Kernel.Mod.Old (.txt) < prev    next >
Encoding:
Oberon Text  |  1995-11-30  |  23.9 KB  |  680 lines  |  [TEXT/.Ob4]
  1. Syntax10.Scn.Fnt
  2. InfoElems
  3. Alloc
  4. Syntax10.Scn.Fnt
  5. StampElems
  6. Alloc
  7. 30 Nov 95
  8. "Title": Kernel.Mod
  9. "Author": mmb 8.5.91 / 13.10.93 / RC 28.10.91 / HM 27.6.94 / mah 16.12.94
  10. "From":  10.02.95 12:30:34
  11. "Until": 
  12. "Changes":
  13. 10.2.95    mah    ptrs <= 0 not marked anymore instead of ptr = 0 as previously
  14. 17.2.95    mah    best fit instead of first fit when allocating a big block 
  15. 27.6.95    mk     finalization, queues are now stacks, prepare Queue added
  16. 29.11.95  mah    CheckCandidates: fix to avoid marking of free blocks
  17. Syntax10b.Scn.Fnt
  18. Syntax10i.Scn.Fnt
  19. FoldElems
  20. Syntax10.Scn.Fnt
  21. IF (heapSize > minHeapSize) & (lastSize >= minHeapExt) THEN    (*<<*)
  22.             lastSize := ShrinkHeap(lastSize)
  23.         END;
  24. Syntax10.Scn.Fnt
  25.         VAR p: FreeBlock; i, size: LONGINT;
  26.     BEGIN
  27.         p := S.VAL(FreeBlock, lastBlock);
  28.         IF p # NIL THEN DEC(requiredSize, p.size + 4) END;
  29.         size := S.VAL(LONGINT, S.VAL(SET, requiredSize+(minHeapExt-1)) - S.VAL(SET, minHeapExt-1));
  30.         Sys.SetPtrSize(heapAdr, heapSize + size);
  31.         IF Sys.MemError() # 0 THEN Sys.Str("Heap overflow$"); HALT(20) END;
  32.         requiredSize := size;
  33.         IF p # NIL THEN
  34.             i := p.size + 4; INC(size, i);
  35.             i := Min(i DIV B, N);
  36.             A[i] := p.next
  37.         ELSE p := S.VAL(FreeBlock, heapEnd)
  38.         END;
  39.         p.tag := S.VAL(Tag, S.ADR(p.size)); p.size := size - 4;
  40.         p.next := A[N]; A[N] := p;
  41.         INC(heapSize, requiredSize); INC(heapEnd, requiredSize)
  42.     END ExpandHeap;
  43. Syntax10.Scn.Fnt
  44.         VAR shrink, newSize: LONGINT;
  45.     BEGIN
  46.         shrink := S.VAL(LONGINT, S.VAL(SET, lastSize) - S.VAL(SET, minHeapExt-1));
  47.         newSize := heapSize - shrink;
  48.         IF newSize < minHeapSize THEN newSize := minHeapSize; shrink := heapSize - minHeapSize END;
  49.         Sys.SetPtrSize(heapAdr, newSize); 
  50.         IF Sys.MemError() # 0 THEN RETURN lastSize
  51.         ELSE DEC(heapSize, shrink); DEC(heapEnd, shrink); RETURN lastSize - shrink
  52.         END
  53.     END ShrinkHeap;
  54. Syntax10.Scn.Fnt
  55.         VAR tag, supertag, x, y: LONGINT; typename: ARRAY 32 OF CHAR; m: Modules.Module;
  56.     BEGIN
  57.         x := p-4;
  58.         REPEAT INC(x, 4); S.GET(x, y) UNTIL y < 0;
  59.         tag := x + y;
  60.         S.GET(tag-4, supertag);
  61.         supertag := S.VAL(LONGINT, S.VAL(SET, supertag) - mark);
  62.         S.MOVE(supertag+16, S.ADR(typename), 32);
  63.         IF (typename # "ObjDesc") & (typename # "StrDesc") & (typename # "NodeDesc") THEN
  64.             S.GET(supertag+48, m);
  65.             Modules.Print(m.name, 0); Modules.Print(". ", 0);
  66.             Modules.Print(typename, 0); Modules.Print(", n = %d$", (p-tag-4) DIV 4)
  67.         END
  68.     END PrintType;
  69. MODULE Kernel;    (* mmb 8.5.91 / 13.10.93 / RC 28.10.91 / HM 27.6.94 / mah 16.12.94 *)
  70. (* Finalization due to J.Templ  implemented by MK 22.2.95 *)
  71. (* memory management and trap handling for PowerMac Oberon *)
  72. (* WARNING: do not use NEW nor SYSTEM.NEW in this module !! use NewRec, NewArr or NewSys instead *)
  73.     IMPORT S := SYSTEM, Modules, Sys;
  74.     CONST
  75.         MarkBit* = 31; ArrayBit = 30; RecBit = 30;
  76.         B = 16;   (*chunk size: memory blocks are allocated in multiples of B bytes*)
  77.         N = 9;  (*number of free lists*)
  78.         mark = {MarkBit}; array = {ArrayBit};
  79.     TYPE
  80.         Tag = POINTER TO TypeDesc;
  81.         TypeDesc = RECORD
  82.             size: LONGINT;
  83.             ptroff: LONGINT
  84.         END;
  85.         FreeBlock = POINTER TO FreeBlockDesc;
  86.         FreeBlockDesc = RECORD
  87.             tag: Tag;
  88.             size: LONGINT;    (*size of block without tag*)
  89.             next: FreeBlock;
  90.             filler: LONGINT;
  91.             firstofnext: LONGINT
  92.         END;
  93.         Block = POINTER TO BlockDesc;
  94.         BlockDesc = RECORD
  95.             last, cur, first: Block    (*fields of open array descriptor*)
  96.         END;
  97.         Blockm4 = POINTER TO Blockm4Desc;
  98.         Blockm4Desc = RECORD
  99.             tag: Tag;
  100.             last, cur, first: LONGINT;
  101.             filler0, filler1, filler2, filler3, firstofnext: LONGINT
  102.         END;
  103.         Stack = POINTER TO StackDesc;
  104.         StackDesc = RECORD
  105.             beg, end: LONGINT;
  106.             next: Stack
  107.         END;
  108.         Notifier* = PROCEDURE;
  109.         Queue* = RECORD
  110.             notify: ARRAY 8 OF Notifier
  111.         END;
  112.         Finalizer* = PROCEDURE (obj: S.PTR);
  113.         FinObj = POINTER TO FinObjNode;
  114.         FinObjNode = RECORD 
  115.             next: FinObj;
  116.             obj: LONGINT;
  117.             marked: BOOLEAN;
  118.             fin: Finalizer
  119.         END;    
  120.         heapBeg*, heapEnd*: LONGINT;    (*borders of used heap (B aligned - 4)*)
  121.         resumeSP*: LONGINT;    (*SP of Oberon.Loop*)
  122.         GCenabled*: BOOLEAN;
  123.         prepQ*, quitQ*, gcQ*: Queue; (* prep queue called before GC, gc queue during GC *)
  124.         finalize: BOOLEAN;  (* flag to avoid finalization in the case: Finalizer starts GC  MK *)
  125.         heapAdr, heapSize: LONGINT;    (*actual heap address and size*)
  126.         resumePC, resumeFP: LONGINT;    (*resume execution after trap here*)
  127.         A: ARRAY N+1 OF FreeBlock;  (*free lists*)
  128.         PointerTD, stackTD: ARRAY 4 OF LONGINT;
  129.         firstStack, curStack: Stack;
  130.         firstTry, checkStack: BOOLEAN;
  131.         candidates: ARRAY 256 OF LONGINT;
  132.         nofcand: INTEGER;
  133.         finObjs*: FinObj;        (* list of objects to be finalized *)
  134.     PROCEDURE^ NewBlock (size: LONGINT): FreeBlock;
  135.     PROCEDURE^ NewRec (tg: LONGINT): LONGINT;
  136.     PROCEDURE^ NewSys (size: LONGINT): LONGINT;
  137.     PROCEDURE^ NewArr (eltg, nofelem, nofdim: LONGINT): LONGINT;
  138.     PROCEDURE^ Mark (block: Block);
  139.     PROCEDURE Min (x, y: LONGINT): LONGINT;
  140.     BEGIN
  141.         IF x < y THEN RETURN x ELSE RETURN y END
  142.     END Min;
  143. (* --- queues --- *)
  144.     PROCEDURE (VAR q: Queue) Init*;
  145.         VAR i: INTEGER;
  146.     BEGIN
  147.         FOR i := 0 TO LEN(q.notify)-1 DO q.notify[i] := NIL END
  148.     END Init;
  149.     PROCEDURE (VAR q: Queue) Add* (notify: Notifier);
  150.         VAR i: INTEGER;
  151.     BEGIN
  152.         FOR i := 0 TO LEN(q.notify)-1 DO
  153.             IF q.notify[i] = NIL THEN q.notify[i] := notify; RETURN END
  154.         END
  155.     END Add;
  156.     PROCEDURE (VAR q: Queue) Remove* (notify: Notifier);
  157.         VAR i: INTEGER;
  158.     BEGIN
  159.         FOR i := 0 TO LEN(q.notify)-1 DO
  160.             IF q.notify[i] = notify THEN q.notify[i] := NIL; RETURN END
  161.         END
  162.     END Remove;
  163.     PROCEDURE (VAR q: Queue) Handle*;
  164.         VAR i: INTEGER;
  165.     BEGIN
  166.         FOR i := LEN(q.notify)-1 TO 0 BY - 1 DO
  167.             IF q.notify[i] # NIL THEN q.notify[i] END
  168.         END
  169.     END Handle;
  170. (* --- finalization --- *)
  171.     PROCEDURE RegisterObject* (obj: S.PTR; fin: Finalizer);
  172.     (* new parameter: atonce *)
  173.         VAR n, n1: FinObj;
  174.         PROCEDURE new (VAR o: S.PTR);
  175.             VAR adr: LONGINT;
  176.         BEGIN 
  177.             adr := NewRec (S.VAL (LONGINT, o));
  178.             S.PUT (S.ADR (o), adr);
  179.         END new;
  180.     BEGIN
  181.         new (n); n.obj := S.VAL (LONGINT, obj); n.marked :=  TRUE; n.fin := fin; n.next := NIL; 
  182.         IF finObjs = NIL THEN finObjs :=n
  183.         ELSE
  184.             n1 := finObjs;
  185.             WHILE n1.next # NIL DO n1 := n1.next END;  
  186.             n1.next := n
  187.         END
  188.     END RegisterObject;
  189.     PROCEDURE FinalizeObjs;
  190.         VAR n, prev: FinObj;
  191.     BEGIN
  192.         IF finalize THEN RETURN END;
  193.         finalize := TRUE;
  194.         n := finObjs; prev := NIL;
  195.         WHILE n # NIL DO
  196.             IF ~ n.marked THEN
  197.                 n.fin (S.VAL (S.PTR, n.obj));
  198.                 IF n = finObjs THEN finObjs := finObjs.next ELSE prev.next := n.next END;
  199.             ELSE prev := n
  200.             END;
  201.             n := n.next
  202.         END;
  203.         finalize := FALSE;
  204.     END FinalizeObjs;
  205.     PROCEDURE FinalizeAll*;
  206.         VAR n, prev: FinObj;
  207.     BEGIN
  208.         finalize := TRUE;
  209.         n := finObjs; 
  210.         WHILE n # NIL DO n.fin (S.VAL (S.PTR, n.obj)); n := n.next END
  211.     END FinalizeAll;
  212.     PROCEDURE CheckFinObjs;
  213.         VAR n: FinObj; tag: LONGINT;
  214.     BEGIN
  215.         n := finObjs;
  216.         WHILE n # NIL DO
  217.             S.GET (n.obj - 4, tag);
  218.             n.marked := MarkBit IN S.VAL (SET, tag);
  219.             n := n.next
  220.         END;
  221.         (* marks all objects accessible from not marked n.obj s to prevent them from being collected *)
  222.         n := finObjs;
  223.         WHILE n # NIL DO    
  224.             S.GET (n.obj - 4, tag);
  225.             IF ~n.marked THEN Mark (S.VAL (Block, n.obj)) END;
  226.             n := n.next
  227.         END;
  228.     END CheckFinObjs;
  229. (* --- memory management --- *)
  230.     PROCEDURE AllocateHeap;
  231.         VAR grow: LONGINT;
  232.     BEGIN
  233.         Sys.MaxApplZone;
  234.         heapSize := Sys.MaxMem(grow) - 1000*1024;
  235.         heapAdr := Sys.NewPtr(heapSize);
  236.         IF heapAdr <= 0 THEN Modules.Print("-- could not allocate heap$", 0) END;
  237.     END AllocateHeap;
  238.     PROCEDURE Available* (): LONGINT;
  239.         VAR i, avail: LONGINT; p: FreeBlock;
  240.     BEGIN
  241.         avail := 0;
  242.         FOR i := 0 TO N DO
  243.             p := A[i];
  244.             WHILE p # NIL DO INC(avail, p.size+4); p := p.next END
  245.         END;
  246.         RETURN avail
  247.     END Available;
  248.     PROCEDURE LargestAvailable* (): LONGINT;
  249.         VAR i, max: LONGINT; p: FreeBlock;
  250.     BEGIN
  251.         i := N; max := 0;
  252.         WHILE (i >= 0) & (max = 0) DO
  253.             p := A[i];
  254.             WHILE p # NIL DO
  255.                 IF p.size > max THEN max := p.size END;
  256.                 p := p.next
  257.             END;
  258.             DEC(i)
  259.         END;
  260.         RETURN max + 4
  261.     END LargestAvailable;
  262.     PROCEDURE RemoveStack* (pos: LONGINT);
  263.         VAR s, last: Stack;
  264.     BEGIN
  265.         s := firstStack;
  266.         WHILE (s # NIL) & ((pos < s.beg) OR (pos > s.end)) DO last := s; s := s.next END;
  267.         IF (s # NIL) & (s # curStack) THEN
  268.             IF s = firstStack THEN firstStack := s.next ELSE last.next := s.next END
  269.         END
  270.     END RemoveStack;
  271.     PROCEDURE AddStack* (beg, end: LONGINT);
  272.         VAR s: Stack;
  273.     BEGIN
  274.         RemoveStack(beg);
  275.         s :=S.VAL(Stack, NewRec(S.ADR(stackTD)+4)) ; s.beg := beg; s.end := end; s.next := firstStack; firstStack := s
  276.     END AddStack;
  277.     PROCEDURE MarkStack*;
  278.         VAR SP: LONGINT;
  279.     BEGIN
  280.         S.GETREG(1, SP); S.GET(SP, curStack.end)
  281.     END MarkStack;
  282.     PROCEDURE Mark (block: Block);
  283.         TYPE
  284.             Tag0 = POINTER TO RECORD
  285.                 (*size: LONGINT;  skipped, because accessed via tag = actual tag + 4*)
  286.                 ptroff: LONGINT
  287.             END;
  288.         VAR cur, prev, p: Block; offset, adr, tdadr: LONGINT; tag, downtag, marked: Tag0; arraybit, set: SET;
  289.     BEGIN
  290.         S.GET(S.VAL(LONGINT, block)-4, tag);
  291.         marked := S.VAL(Tag0, S.VAL(SET, tag) + mark);
  292.         IF tag # marked THEN
  293.             (*---- mark type descriptor*)
  294.             tdadr := S.VAL(LONGINT, S.VAL(SET, tag) - array) - 4;
  295.             S.GET (tdadr, set); 
  296.             IF RecBit IN set THEN tdadr := S.VAL(LONGINT, set - {RecBit, MarkBit}) - 4; S.GET(tdadr, set) END;
  297.             S.PUT(tdadr, set + mark);
  298.             (*---- mark object*)
  299.             S.PUT(S.VAL(LONGINT, block)-4, marked);
  300.             arraybit := S.VAL(SET, tag) * array;
  301.             IF arraybit # {} THEN
  302.                 cur := block.first;
  303.                 tag := S.VAL(Tag0, S.VAL(SET, tag) - arraybit)
  304.             ELSE cur := block
  305.             END;
  306.             prev := NIL;
  307.             LOOP
  308.                 INC(S.VAL(LONGINT, tag), 4);
  309.                 offset := tag.ptroff;
  310.                 IF offset < 0 THEN  (*up*)
  311.                     INC(S.VAL(LONGINT, tag), offset);
  312.                     IF (arraybit # {}) & (cur # block.last) THEN
  313.                         INC(S.VAL(LONGINT, cur), tag.ptroff)    (* INC(cur, recsize) *)
  314.                     ELSE (* up *)
  315.                         S.PUT(S.VAL(LONGINT, block)-4, S.VAL(SET, tag) + arraybit + mark);
  316.                         IF prev = NIL THEN EXIT END;
  317.                         S.GET(S.VAL(LONGINT, prev)-4, tag);
  318.                         arraybit := S.VAL(SET, tag) * array;
  319.                         tag := S.VAL(Tag0, S.VAL(SET, tag) - array - mark);
  320.                         IF arraybit # {} THEN cur := prev.cur ELSE cur := prev END;
  321.                         adr := S.VAL(LONGINT, cur) + tag.ptroff;
  322.                         S.GET(adr, p);
  323.                         S.PUT(adr, block);
  324.                         block := prev;
  325.                         prev := p
  326.                     END
  327.                 ELSE  (*down*)
  328.                     adr := S.VAL(LONGINT, cur) + offset;
  329.                     S.GET(adr, p);
  330.                     IF S.VAL (LONGINT, p) > 0 THEN
  331.                         S.GET(S.VAL(LONGINT, p)-4, downtag);
  332.                         marked := S.VAL(Tag0, S.VAL(SET, downtag) + mark);
  333.                         IF downtag # marked THEN
  334.                             (*---- mark type descriptor*)
  335.                             tdadr := S.VAL(LONGINT, S.VAL(SET, downtag) - array) - 4;
  336.                             S.GET (tdadr, set); 
  337.                             IF RecBit IN set THEN tdadr := S.VAL(LONGINT, set - {RecBit, MarkBit}) - 4; S.GET(tdadr, set) END;
  338.                             S.PUT(tdadr, set + mark);
  339.                             (*---- mark object*)
  340.                             S.PUT(S.VAL(LONGINT, p)-4, marked);
  341.                             S.PUT(S.VAL(LONGINT, block)-4, S.VAL(SET, tag) + arraybit + mark);
  342.                             IF arraybit # {} THEN block.cur:= cur END;
  343.                             arraybit := S.VAL(SET, downtag) * array;
  344.                             IF arraybit # {} THEN cur := p.first ELSE cur := p END;
  345.                             tag := S.VAL(Tag0, S.VAL(SET, downtag) - arraybit);
  346.                             S.PUT(adr, prev);
  347.                             prev := block;
  348.                             block := p
  349.                         END
  350.                     END
  351.                 END
  352.             END
  353.         END
  354.     END Mark;
  355.     PROCEDURE Sweep;
  356.         VAR p, end: Blockm4; free: FreeBlock; tag, unmarked, tdesc: Tag; size, lastSize, i: LONGINT;
  357.             last: ARRAY N+1 OF FreeBlock;
  358.     BEGIN
  359.         FOR i :=0 TO N DO A[i] := NIL END;
  360.         (*-- sweep through all blocks*)
  361.         p := S.VAL(Blockm4, heapBeg);
  362.         end := S.VAL(Blockm4, heapEnd);
  363.         lastSize := 0;
  364.         WHILE p # end DO
  365.             tag := p.tag;
  366.             unmarked := S.VAL(Tag, S.VAL(SET, tag) - mark);
  367.             tdesc := S.VAL(Tag, S.VAL(SET, unmarked) - array);
  368.             IF unmarked # tdesc THEN (*array block*)
  369.                 size := p.last + tdesc.size - S.VAL(LONGINT, p)
  370.             ELSE size := tdesc.size + 4
  371.             END;
  372.             size := S.VAL(LONGINT, S.VAL(SET, size + B-1) - S.VAL(SET, B-1));
  373.             IF tag = unmarked THEN (*collect*)
  374. Modules.Print ("Size = %d$", size);
  375.                 IF lastSize = 0 THEN free := S.VAL(FreeBlock, p) END;
  376.                 INC(lastSize, size)
  377.             ELSE
  378.                 p.tag := unmarked;
  379.                 IF lastSize > 0 THEN  (*add last free block to free list*)
  380. Modules.Print ("Merged = %d$", lastSize);
  381.                     free.size := lastSize - 4;
  382.                     free.tag := S.VAL(Tag, S.ADR(free.size));
  383.                     i := Min(lastSize DIV B, N);
  384.                     IF A[i] = NIL THEN A[i] := free ELSE last[i].next := free END;
  385.                     last[i] := free; free.next := NIL; lastSize := 0
  386.                 END
  387.             END;
  388.             INC(S.VAL(LONGINT, p), size)
  389.         END;
  390. shrink heap
  391.         (*-- add last free block to free list*)
  392.         IF lastSize > 0 THEN
  393. Modules.Print ("Merged = %d$", lastSize);
  394.             free.size := lastSize - 4;
  395.             free.tag := S.VAL(Tag, S.ADR(free.size));
  396.             i := Min(lastSize DIV B, N);
  397.             IF A[i] = NIL THEN A[i] := free ELSE last[i].next := free END;
  398.             last[i] := free; free.next := NIL
  399.         END
  400.     END Sweep;
  401.     PROCEDURE CheckCandidates;    (*nofcand > 0*)
  402.         VAR h, i, j, size, cand, block, last, heapEnd0: LONGINT; tag, unmarked, tdesc: Tag;
  403.     BEGIN
  404.         (*-- sort candidates in increasing order using shellsort *)
  405.         h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
  406.         REPEAT h := h DIV 3; i := h;
  407.             WHILE i < nofcand DO cand := candidates[i]; j := i;
  408.                 WHILE (j >= h) & (candidates[j-h] > cand) DO
  409.                     candidates[j] := candidates[j-h]; j := j-h;
  410.                 END;
  411.                 candidates[j] := cand; INC(i)
  412.             END
  413.         UNTIL h = 1;
  414.         (*-- sweep*)
  415.         block := heapBeg + 4; heapEnd0 := heapEnd + 4;
  416.         i := 0; cand := candidates[i];
  417.         LOOP
  418.             IF cand <= block THEN
  419.                 IF cand = block THEN 
  420.                     S.GET(cand-4, h);
  421.                     IF h # cand THEN Mark(S.VAL(Block, cand)) END    (* else it is a free block *)
  422.                 END;
  423.                 INC(i);
  424.                 IF i = nofcand THEN EXIT END;
  425.                 cand := candidates[i]
  426.             ELSE (*cand > block*)
  427.                 S.GET(block-4, tag);
  428.                 unmarked := S.VAL(Tag, S.VAL(SET, tag) - mark);
  429.                 tdesc := S.VAL(Tag, S.VAL(SET, unmarked) - array);
  430.                 IF tdesc # unmarked THEN (*array block*) S.GET(block, last); size := last + tdesc.size - block + 4
  431.                 ELSE size := tdesc.size + 4
  432.                 END;
  433.                 INC(block, S.VAL(LONGINT, S.VAL(SET, size + B-1) - S.VAL(SET, B-1)));
  434.                 IF block = heapEnd0 THEN EXIT END
  435.             END
  436.         END;
  437.         nofcand := 0
  438.     END CheckCandidates;
  439.     PROCEDURE Candidate (p: LONGINT);
  440.         VAR tag: LONGINT;
  441.     BEGIN
  442.         IF (p MOD B = 0) & (p >= heapBeg) & (p < heapEnd) THEN
  443.             S.GET(p-4, tag);
  444.             IF ~ODD(tag) (*unmarked*) THEN
  445.                 candidates[nofcand] := p; INC(nofcand);
  446.                 IF nofcand = LEN(candidates) THEN CheckCandidates END
  447.             END
  448.         END
  449.     END Candidate;
  450.     PROCEDURE SetMark (adr: LONGINT);
  451.         VAR set: SET;
  452.     BEGIN
  453.         S.GET (adr - 4, set); set := set + mark; S.PUT (adr - 4, set)
  454.     END SetMark;
  455.     PROCEDURE CheckMark (adr: LONGINT);
  456.         VAR set: SET;
  457.     BEGIN
  458.         S.GET (adr - 4, set);
  459.         IF MarkBit IN  set THEN Modules.Print ("Check: %x", S.VAL (LONGINT, set)); Modules.Print (", %x$", adr) END;
  460.     END CheckMark;
  461.     PROCEDURE GC*;
  462.         VAR m: Modules.Module; i, data, offset, beg, p: LONGINT; ptr: Block; s: Stack; set: SET;
  463.     BEGIN
  464.         IF GCenabled THEN
  465.             prepQ.Handle;
  466.             FOR i := 0 TO N DO A[i] := NIL END;
  467.             m := Modules.modules;
  468.             WHILE m # NIL DO
  469.                 SetMark (S.VAL(LONGINT, m)); SetMark (m.block- 4);
  470.                 data := m.SB;
  471.                 FOR i := 0 TO m.nofptrs - 1 DO
  472.                     S.GET(m.pointers + 4*i, offset);
  473.                     S.GET(data + offset, ptr);
  474.                     IF S.VAL (LONGINT, ptr) > 0 THEN Mark(ptr) END
  475.                 END;
  476.                 FOR i := 0 TO m.noftds - 1 DO
  477.                     S.GET (m.typedescs + 4*i, p);
  478.                     S.GET (p-4, set);
  479.                     p := S.VAL(LONGINT, set - {RecBit, MarkBit});
  480.                     IF RecBit IN set THEN SetMark(p) END
  481.                 END;
  482.                 m := m.link
  483.             END;
  484.             IF checkStack THEN
  485.                 MarkStack;
  486.                 s := firstStack; nofcand := 0;
  487.                 WHILE s # NIL DO
  488.                     i := s.end; beg := s.beg;
  489.                     WHILE i < beg DO
  490.                         S.GET(i, p); Candidate(p);
  491.                         INC(i, 4)
  492.                     END;
  493.                     s := s.next
  494.                 END;
  495.                 (*-- callee-saved general registers *)
  496.                 S.GETREG(13, p); Candidate(p);
  497.                 S.GETREG(14, p); Candidate(p);
  498.                 S.GETREG(15, p); Candidate(p);
  499.                 S.GETREG(16, p); Candidate(p);
  500.                 S.GETREG(17, p); Candidate(p);
  501.                 S.GETREG(18, p); Candidate(p);
  502.                 S.GETREG(19, p); Candidate(p);
  503.                 S.GETREG(20, p); Candidate(p);
  504.                 S.GETREG(21, p); Candidate(p);
  505.                 S.GETREG(22, p); Candidate(p);
  506.                 S.GETREG(23, p); Candidate(p);
  507.                 S.GETREG(24, p); Candidate(p);
  508.                 S.GETREG(25, p); Candidate(p);
  509.                 S.GETREG(26, p); Candidate(p);
  510.                 S.GETREG(27, p); Candidate(p);
  511.                 S.GETREG(28, p); Candidate(p);
  512.                 S.GETREG(29, p); Candidate(p);
  513.                 S.GETREG(30, p); Candidate(p);
  514.                 IF nofcand > 0 THEN CheckCandidates END
  515.             END;
  516.             CheckFinObjs;     (* finalization MK *)
  517.             gcQ.Handle;
  518.             Sweep;
  519.             m:= Modules.modules;
  520.             WHILE m # NIL DO
  521. (*                CheckMark (S.VAL(LONGINT, m)); CheckMark (m.block-4);*)
  522.                 FOR i := 0 TO m.noftds - 1 DO
  523.                     S.GET (m.typedescs + 4*i, p);
  524.                     S.GET (p-4, set);
  525.                     p := S.VAL(LONGINT, set - {RecBit, MarkBit});
  526. (*                    IF RecBit IN set THEN CheckMark(p) END*)
  527.                 END;
  528.                 m := m.link
  529.             END;
  530.             FinalizeObjs  (* finalization MK *)
  531.         END
  532.     END GC;
  533.     PROCEDURE NewBlock (size: LONGINT): FreeBlock;    (* size MOD B = 0 *)
  534.         VAR i, rest: LONGINT; p, q, lp, lq: FreeBlock;
  535.     BEGIN
  536.         i := Min(size DIV B, N);
  537.         WHILE (i < N) & (A[i] = NIL) DO INC(i) END;
  538.         IF i = N THEN 
  539.             lp := A[i];
  540.             WHILE lp # NIL DO                        (* 17.2.85 mah *)
  541.                 IF lp.size + 4 >= size THEN
  542.                     IF (p = NIL) OR (p.size > lp.size) THEN p :=  lp; q := lq END
  543.                 END;
  544.                 lq := lp; lp := lp.next
  545.             END;
  546.             IF p = NIL THEN
  547.                 IF firstTry THEN
  548.                     GC;
  549.                     firstTry := FALSE; p := NewBlock(size); firstTry := TRUE;
  550.                     RETURN p
  551.                 ELSE
  552.                     Modules.Print("--- heap overflow$", 0); HALT(20)
  553.                 END
  554.             ELSIF q # NIL THEN q.next := p.next
  555.             ELSE A[N] := p.next
  556.             END
  557.         ELSE (*p # NIL *) p := A[i]; A[i] := p.next
  558.         END;
  559.         rest := p.size + 4 - size;
  560.         IF rest > 0 THEN
  561.             IF size > 10 * 1024 THEN
  562.                 q := p;
  563.                 p := S.VAL(FreeBlock, S.VAL(LONGINT, p) + rest)
  564.             ELSE
  565.                 q := S.VAL(FreeBlock, S.VAL(LONGINT, p) + size)
  566.             END;
  567.             q.tag := S.VAL(Tag, S.ADR(q.size));
  568.             q.size := rest - 4;
  569.             i := Min(rest DIV B, N); q.next := A[i]; A[i] := q
  570.         END;
  571.         RETURN p
  572.     END NewBlock;
  573.     PROCEDURE NewRec (tg: LONGINT): LONGINT;    (* implementation of NEW(p) *)
  574.         VAR size, null: LONGINT; p, q: FreeBlock; tag: Tag;    BEGIN (* tag.size = rectyp.size *)
  575.         tag := S.VAL(Tag, tg);
  576.         size := S.VAL(LONGINT, S.VAL(SET, tag.size + 4 (*tag*) + B-1) - S.VAL(SET, B-1));
  577.         p := NewBlock(size);
  578.         (*-- the following code is optimized for RISC processors*)
  579.         q := S.VAL(FreeBlock, S.VAL(LONGINT, p) + size - B);
  580.         null := 0;
  581.         q.size := null; q.next := S.VAL(FreeBlock, null); q.filler := null;
  582.         WHILE q # p DO
  583.             DEC(S.VAL(LONGINT, q), B);
  584.             q.size := null; q.next := S.VAL(FreeBlock, null); q.filler := null; q.firstofnext := null (* q.firstofnext is in next block *)
  585.         END;
  586.         p.tag := tag;
  587.         RETURN S.VAL(LONGINT, p) + 4
  588.     END NewRec;
  589.     PROCEDURE NewSys (size: LONGINT): LONGINT;    (* implementation of S.NEW(p, size) *)
  590.         VAR p, q: FreeBlock; null: LONGINT;
  591.     BEGIN                                                        (* mah:   v  12 statt 8 to allow NEW (string, 4) to work correctly *)
  592.         size := S.VAL(LONGINT, S.VAL(SET, size + (4 (*tag*) + 12 (*dummyTD*) + B-1)) - S.VAL(SET, B-1));
  593.         p := NewBlock(size);
  594.         (*-- set up dummyTD at the end of the block in order to treat system blocks like unmarked blocks*)
  595.         q := S.VAL(FreeBlock, S.VAL(LONGINT, p) + size - B);
  596.         p.tag := S.VAL(Tag, S.ADR(q.next));
  597.         q.size := 0; q.next := S.VAL(FreeBlock, size - 4); q.filler := -4;
  598.         (*-- the following code is optimized for RISC processors*)
  599.         null := 0;
  600.         WHILE q # p DO
  601.             DEC(S.VAL(LONGINT, q), B);
  602.             q.size := null; q.next := S.VAL(FreeBlock, null); q.filler := null; q.firstofnext := null (* q.firstofnext is in next block *)
  603.         END;
  604.         RETURN S.VAL(LONGINT, p) + 4
  605.     END NewSys;
  606.     PROCEDURE NewArr (eltg, nofelem, nofdim: LONGINT): LONGINT; (* implementation of NEW(p, dim0, dim1, ...) *)
  607.         VAR size, first, elSize, arrSize, vectSize, null: LONGINT; p, q: Blockm4; eltag: Tag;
  608.     BEGIN
  609.         eltag := S.VAL(Tag, eltg);
  610.         IF eltag = NIL THEN (*ARRAY OF POINTER*) eltag := S.VAL(Tag, S.ADR(PointerTD[1])) END;
  611.         elSize := eltag.size;
  612.         arrSize := nofelem*elSize;
  613.         vectSize := 8*(nofdim DIV 2) + 4;    (* -> ADR(first) MOD 8 = 0 *)
  614.         IF eltag.ptroff = -4 THEN (*no pointers in element type*) RETURN NewSys(arrSize + vectSize + 12) END;
  615.         size := S.VAL(LONGINT, S.VAL(SET, arrSize + vectSize + (16 + B-1))-S.VAL(SET, B-1));
  616.         p := S.VAL(Blockm4, NewBlock(size));
  617.         q := S.VAL(Blockm4, S.VAL(LONGINT, p) + size - 2*B);
  618.         (*-- the following code is optimized for RISC processors*)
  619.         null := 0;
  620.         q.filler1 := null; q.filler2 := null; q.filler3 := null;
  621.         WHILE q # p DO
  622.             DEC(S.VAL(LONGINT, q), B);
  623.             q.filler1 := null; q.filler2 := null; q.filler3 := null; q.firstofnext := null (* q.firstofnext is in next block *)
  624.         END;
  625.         p.tag := S.VAL(Tag, S.VAL(SET, eltag) + array);
  626.         first := S.ADR(p.first) + 4 + vectSize;
  627.         p.last := first + arrSize - elSize;
  628.         (*p.cur is reserved for Mark phase*)
  629.         p.first := first;
  630.         p.filler0 := null;
  631.         RETURN S.VAL(LONGINT, p) + 4
  632.     END NewArr;
  633. (* --- trap handling --- *)
  634.     PROCEDURE MarkState*;    (*called at the very beginning of Oberon.Loop*)
  635.         VAR SP: LONGINT;
  636.     BEGIN
  637.         S.GETREG(1, SP); S.GET(SP, resumeSP); S.GET (resumeSP-4, resumeFP); S.GETREG(40 (*LR*), resumePC);
  638.         curStack := S.VAL(Stack, NewRec(S.ADR(stackTD)+4)); curStack.beg := resumeSP; curStack.next := NIL;
  639.         firstStack := curStack
  640.     END MarkState;
  641.     PROCEDURE Resume* (context: Sys.ExceptionInfo);
  642.     BEGIN
  643.         context.reg.R[31*2+1] := resumeFP;
  644.         context.spec.PC := resumePC;
  645.     END Resume;
  646. (* --- initialization --- *)
  647.     PROCEDURE Init;
  648.         VAR a: LONGINT; size, i: LONGINT; p: FreeBlock;
  649.     BEGIN
  650.         firstTry := TRUE; GCenabled := TRUE; checkStack := TRUE;
  651.         Modules.NewRec := NewRec; Modules.NewSys := NewSys; Modules.NewArr := NewArr;
  652.         PointerTD[0] := S.VAL(LONGINT, mark);    (*marked*)
  653.         PointerTD[1] := 4;    (*pointer size*)
  654.         PointerTD[2] := 0;    (*pointer offset in element*)
  655.         PointerTD[3] := -8;    (*sentinel*)
  656.         stackTD[0] := S.VAL(LONGINT, mark);
  657.         stackTD[1] := 12;  (*size*)
  658.         stackTD[2] := 8;   (*offset of next*)
  659.         stackTD[3] := -8; (*sentinel*)
  660.         quitQ.Init; gcQ.Init; prepQ.Init;
  661.         finObjs := NIL; finalize := FALSE; (* finalization MK *)
  662.         (*-- allocate heap; adjust to multiple of B minus 4*)
  663.         AllocateHeap;
  664.         heapBeg := heapAdr + ((-heapAdr-4) MOD B);    (*B aligned - 4*)
  665.         size := heapAdr + heapSize - heapBeg;
  666.         DEC(size, size MOD B);
  667.         heapEnd := heapBeg + size;    (*B aligned - 4*)
  668.         (*-- make the whole heap a single free block*)
  669.         p := S.VAL(FreeBlock, heapBeg);
  670.         p.tag := S.VAL(Tag, S.ADR(p.size)); p.size := size - 4; p.next := NIL;
  671.         A[N] := p;
  672.         FOR i := 0 TO N-1 DO A[i] := NIL END;
  673.     END Init;
  674. BEGIN
  675.     Init
  676. END Kernel.
  677.     PROCEDURE ExpandHeap (requiredSize: LONGINT);    
  678.     PROCEDURE ShrinkHeap (lastSize: LONGINT): LONGINT;    
  679.     PROCEDURE PrintType (p: LONGINT);    
  680.